home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / BBS_UTL / DDPLUS71 / DDSCOTT.PAS < prev    next >
Pascal/Delphi Source File  |  1995-04-03  |  10KB  |  508 lines
  1. unit ddscott;
  2.  
  3. interface
  4. uses dos,crt;
  5. type
  6.  adaptertype= (MDA,CGA,EGAMono,EGAColor);
  7.  datetype=string[6];
  8.  screentype= array[1..4000] of byte;
  9.  screenptr=^screentype;
  10. var
  11.  Tasker  : byte;
  12.  screen: screenptr;
  13.  x,y: integer;
  14.  ch: char;
  15.  DOS_Major,DOS_Minor,Os2Vers : Word;
  16.  hexon,OS2OK,WinOK,WinNTOK,DVOK : Boolean;
  17.  
  18. function va(n: integer): string;
  19. function wva(n: word): string;
  20. function lva(n: longint): string;
  21. function rva(n: real): string;
  22. function stu(s: string): string;
  23. function locase(c: char): char;
  24. function stl(s: string): string;
  25. function namestr(s: string): string;
  26. function exist(file_name: string): boolean;
  27. procedure delete_file(fn: string);
  28. procedure setmode(modenumber: byte);
  29. { procedure set43lines; }
  30. procedure set25lines;
  31. function isega: boolean;
  32. function queryadaptertype: adaptertype;
  33. function determinepoints: integer;
  34. procedure cursoron;
  35. procedure cursoroff;
  36. procedure cursorblock;
  37. function screenaddress: word;
  38. procedure savescreen;
  39. procedure restorescreen;
  40. function date: datetype;
  41. function bitcheck(n: word; b: byte): boolean;
  42. procedure setbit(var n: word; b: byte);
  43. procedure resetbit(var n: word; b: byte);
  44. function hex(i: byte): string;
  45. procedure HexFilt(var s: string);
  46. procedure HexToDec(var s: string);
  47.  
  48. implementation
  49.  
  50. function hex(i: byte): string;
  51. const
  52.  ss: string='0123456789ABCDEF';
  53. var
  54.  hibyte,lobyte: byte;
  55. begin;
  56.  hibyte:=i div 16;
  57.  lobyte:=i-((i div 16)*16);
  58.  hex:=ss[hibyte+1]+ss[lobyte+1];
  59. end;
  60.  
  61. procedure HexFilt(var s: string);
  62. var
  63.  s2,s3: string;
  64.  numst: string;
  65.  r: real;
  66.  a,b: integer;
  67.  e: integer;
  68.  d: longint;
  69.  c: array[1..4] of byte absolute d;
  70. begin;
  71.  s:=s+#13;
  72.  s2:='';
  73.  numst:='';
  74.  for a:=1 to length(S) do begin;
  75.   if s[a] in ['0'..'9'] then numst:=numst+s[a] else begin;
  76.    if (numst<>'') then begin;
  77.     val(numst,r,b);
  78.     str(r:0:0,s3);
  79.     val(s3,r,b);
  80.     e:=a-1;
  81.     b:=0;
  82.     repeat
  83.      e:=e+1;
  84.      if upcase(s[e])='H' then b:=1;
  85.     until (s[e]=' ') or (e>=length(s)) or (s[e]=#13) or (s[e]=#10);
  86.     if (r<2000000000) and (b=0) then begin;
  87.      d:=trunc(r);
  88.      numst:=hex(c[4])+hex(c[3])+hex(c[2])+hex(c[1]);
  89.      while (length(numst)>0) and (numst[1]='0') do delete(numst,1,1);
  90.      if (length(numst)=0) or (not (numst[1] in ['0'..'9'])) then numst:='0'+numst;
  91.      numst:=numst+'h';
  92.     end;
  93.     s2:=s2+numst;
  94.     numst:='';
  95.    end;
  96.    s2:=s2+s[a];
  97.   end;
  98.  end;
  99.  delete(s2,length(s2),1);
  100.  s:=s2;
  101. end;
  102.  
  103. procedure HexToDec(var s: string);
  104. const
  105.  ss: string ='0123456789ABCDEF';
  106. var
  107.  d: longint;
  108.  c: array[1..4] of byte absolute d;
  109. begin;
  110.  if length(s)=0 then exit;
  111.  if upcase(s[length(s)])<>'H' then exit;
  112.  if not (s[1] in ['0'..'9']) then exit;
  113.  delete(s,length(s),1);
  114.  if length(s)=0 then exit;
  115.  while length(s)<8 do s:='0'+s;
  116.  c[1]:=(pos(upcase(s[8]),ss)-1)+(pos(upcase(s[7]),ss)-1)*16;
  117.  c[2]:=(pos(upcase(s[6]),ss)-1)+(pos(upcase(s[5]),ss)-1)*16;
  118.  c[3]:=(pos(upcase(s[4]),ss)-1)+(pos(upcase(s[3]),ss)-1)*16;
  119.  c[4]:=(pos(upcase(s[2]),ss)-1)+(pos(upcase(s[1]),ss)-1)*16;
  120.  str(d,s);
  121. end;
  122.  
  123. procedure delete_file(fn: string);
  124. var
  125.  f: file;
  126. begin;
  127.  assign(f,fn);
  128.  erase(f);
  129. end;
  130.  
  131. function va(n: integer): string;
  132. var
  133.  v: string;
  134. begin;
  135.  str(n,v);
  136.  if hexon then hexfilt(v);
  137.  va:=v;
  138. end;
  139.  
  140. function wva(n: word): string;
  141. var
  142.  v: string;
  143. begin;
  144.  str(n,v);
  145.  if hexon then hexfilt(v);
  146.  wva:=v;
  147. end;
  148.  
  149. function lva(n: longint): string;
  150. var
  151.  v: string;
  152. begin;
  153.  str(n,v);
  154.  if hexon then hexfilt(v);
  155.  lva:=v;
  156. end;
  157.  
  158. function rva(n: real): string;
  159. var
  160.  v: string;
  161. begin;
  162.  str(n:0:0,v);
  163.  if hexon then hexfilt(v);
  164.  rva:=v;
  165. end;
  166.  
  167. function stu(s: string): string;
  168. var
  169.  a: integer;
  170. begin;
  171.  for a:=1 to length(s) do s[a]:=upcase(s[a]);
  172.  stu:=s;
  173. end;
  174.  
  175. function locase(c: char): char;
  176. begin;
  177.  if (c>='A') and (c<='Z') then c:=chr(ord(c)+32);
  178.  locase:=c;
  179. end;
  180.  
  181. function stl(s: string): string;
  182. var
  183.  a: integer;
  184. begin;
  185.  for a:=1 to length(s) do s[a]:=locase(s[a]);
  186.  stl:=s;
  187. end;
  188.  
  189. Function exist(file_name: string): boolean;
  190. var
  191.  f: text;
  192.  b: boolean;
  193. begin;
  194.  assign(f,file_name);
  195.  {$I-} reset(f); {$I+}
  196.  if ioresult<>0 then b:=false else b:=true;
  197.  if b then close(f);
  198.  exist:=b;
  199. end;
  200.  
  201. function namestr(s: string): string;
  202. var
  203.  a: integer;
  204. begin;
  205.  s:=stl(s);
  206.  if length(s)>2 then begin;
  207.   s[1]:=upcase(s[1]);
  208.   for a:=1 to length(s) do begin;
  209.    if (s[a] in ['.',' ',',',':',';','-','_','(',')']) and (a+1<length(s)) then s[a+1]:=upcase(s[a+1]);
  210.   end;
  211.  end;
  212.  namestr:=s;
  213. end;
  214.  
  215. procedure setmode(modenumber: byte);
  216. var
  217.  regs: registers;
  218. begin;
  219.  regs.ah:=0;
  220.  regs.al:=modenumber;
  221.  intr($10,regs);
  222. end;
  223.  
  224. procedure set25lines;
  225. var
  226.  regs: registers;
  227. begin;
  228.  regs.ax:=$1111;
  229.  regs.bx:=0;
  230.  intr($10,regs);
  231.  mem[$40:$87]:=mem[$40:$87] or $01;
  232.  regs.ax:=$100;
  233.  regs.bx:=0;
  234.  regs.cx:=$0C00;
  235.  intr($10,regs);
  236. end;
  237.  
  238. function isega: boolean;
  239. var
  240.  regs: registers;
  241. begin;
  242.  regs.ah:=$12;
  243.  regs.bx:=$10;
  244.  intr($10,regs);
  245.  if regs.bx=$10 then isega:=false else isega:=true;
  246. end;
  247.  
  248. function QueryAdapterType: Adaptertype;
  249. var
  250.  regs: registers;
  251.  code: byte;
  252. begin;
  253.  if isega then begin;
  254.   regs.ah:=$12;
  255.   regs.bx:=$10;
  256.   intr($10,regs);
  257.   if (regs.bh=0) then queryadaptertype:=egacolor else queryadaptertype:=egamono;
  258.  end else begin;
  259.   intr($11,regs);
  260.   code:=(regs.al and $30) shr 4;
  261.   case code of
  262.    1: queryadaptertype:=cga;
  263.    2: queryadaptertype:=cga;
  264.    3: queryadaptertype:=mda;
  265.   else queryadaptertype:=cga;
  266.   end;
  267.  end;
  268. end;
  269.  
  270. procedure cursoroff;
  271. var
  272.  regs: registers;
  273. begin;
  274.  regs.ax:=$0100;
  275.  regs.cx:=$2000;
  276.  intr($10,regs);
  277. end;
  278.  
  279. function determinepoints: integer;
  280. var
  281.  regs: registers;
  282. begin;
  283.  case queryadaptertype of
  284.   cga: determinepoints:=8;
  285.   mda: determinepoints:=14;
  286.   egamono, egacolor: begin;
  287.                       regs.ax:=$1130;
  288.                       regs.bx:=0;
  289.                       intr($10,regs);
  290.                       determinepoints:=regs.cx;
  291.                      end;
  292.  end;
  293. end;
  294.  
  295. procedure cursoron;
  296. var
  297.  regs: registers;
  298. begin;
  299.  regs.ax:=$0100;
  300.  regs.ch:=determinepoints-2;
  301.  regs.cl:=determinepoints-1;
  302.  intr($10,regs);
  303. end;
  304.  
  305. procedure cursorblock;
  306. var
  307.  regs: registers;
  308. begin;
  309.  regs.ax:=$0100;
  310.  regs.ch:=1;
  311.  regs.cl:=determinepoints-1;
  312.  intr($10,regs);
  313. end;
  314.  
  315. function screenaddress: word;
  316. begin;
  317.  case queryadaptertype of
  318.   cga: screenaddress:=$B800;
  319.   mda: screenaddress:=$b000;
  320.   egamono: screenaddress:=$b000;
  321.   egacolor: screenaddress:=$b800;
  322.  end;
  323. end;
  324.  
  325. procedure savescreen;
  326. var
  327.  sc1: byte absolute $b000:0;
  328.  sc2: byte absolute $b800:0;
  329. begin;
  330.  if screenaddress=$b000 then move(sc1,screen^,4000);
  331.  if screenaddress=$b800 then move(sc2,screen^,4000);
  332.  x:=wherex;
  333.  y:=wherey;
  334. end;
  335.  
  336. procedure restorescreen;
  337. var
  338.  sc1: byte absolute $b800:0;
  339.  sc2: byte absolute $b000:0;
  340. begin;
  341.  if screenaddress=$b000 then move(screen^, sc2,4000);
  342.  if screenaddress=$b800 then move(screen^, sc1,4000);
  343.  gotoxy(x,y);
  344. end;
  345.  
  346. function date: datetype;
  347. var
  348.  d,m,y,dow: word;
  349.  s,s2: string[6];
  350. begin;
  351.  getdate(y,m,d,dow);
  352.  y:=y-1900;
  353.  s:=va(m);
  354.  if length(s)=1 then s:='0'+s;
  355.  s2:=va(d);
  356.  if length(s2)=1 then s2:='0'+s2;
  357.  s:=s+s2;
  358.  s2:=va(y);
  359.  if length(s2)=1 then s2:='0'+s2;
  360.  s:=s+s2;
  361.  date:=s;
  362. end;
  363.  
  364. function bitcheck(n: word; b: byte): boolean;
  365. var
  366.  a,c: integer;
  367. begin;
  368.  a:=2;
  369.  for c:=1 to b do a:=a*2;
  370.  if (a and n)<>0 then bitcheck:=true else bitcheck:=false;
  371. end;
  372.  
  373. procedure setbit(var n: word; b: byte);
  374. var
  375.  a,c: integer;
  376. begin;
  377.  a:=2;
  378.  for c:=1 to b do a:=a*2;
  379.  n:=(a or n);
  380. end;
  381.  
  382. procedure resetbit(var n: word; b: byte);
  383. var
  384.  a,c: integer;
  385. begin;
  386.  a:=2;
  387.  for c:=1 to b do a:=a*2;
  388.  a:= not a;
  389.  n:=(a and n);
  390. end;
  391.  
  392. function TrueDosVer (var WinNtOK :boolean): Word;
  393. var
  394.  Regs: Registers;
  395. Begin
  396.   with Regs do
  397.   begin
  398.     Ax := $3306;
  399.     MsDos(Regs);
  400.     If Bx = $3205 then
  401.       WinNtOK := true
  402.     else
  403.       WinNtOK := false;
  404.     TrueDosVer := Bl;
  405.   end;
  406. end;
  407.  
  408. function DosVer(var Minor,OS2Ver : Word) : Word;
  409. var
  410.  Regs: Registers;
  411. Begin
  412.   OS2Ver := 0;
  413.   with Regs do
  414.   begin
  415.     Ax := $3000;
  416.     MsDos(Regs);
  417.     DosVer := Al;
  418.     Minor  := Ah;
  419.     If Al = $0A then
  420.       OS2Ver := 1
  421.     else
  422.     If Al = $14 then
  423.       OS2Ver := 2;
  424.   end;
  425. end;
  426.  
  427. Function Win3_Check_On: boolean;
  428. const
  429.   Multplx_intr = $2F;
  430. var
  431.   Regs : registers;
  432. begin
  433.   With Regs do
  434.   begin
  435.     AX := $1600;
  436.     Intr(Multplx_intr,regs);                { $00 no Win 2.x or 3.x      }
  437.     if AL in [$00,$01,$80,$FF] then         { $01 Win/386 2.x running    }
  438.       Win3_Check_On := false                { $80 obsolete XMS installed }
  439.     else                                    { $FF Win/386 2.x running    }
  440.       Win3_Check_On := true;
  441.    end;
  442. end;
  443.  
  444. Function DV_Check_On : boolean;
  445. var
  446.   Regs : registers;
  447. begin
  448.   DV_Check_On := false;
  449.   With Regs do
  450.   begin
  451.     Ax := $2B01;
  452.     Cx := $4445;
  453.     Dx := $5351;
  454.     Intr($21,Regs);
  455.   end;
  456.   If (Regs.AL = $FF) then
  457.      DV_Check_On := false
  458.   else
  459.      DV_Check_On := true;
  460. end;
  461.  
  462. Procedure FindTaskerType;  { Find what tasker if any is being used      }
  463. var
  464.  D5 : word;
  465. begin
  466.  D5 := 0;
  467.  Tasker := 0;
  468.  DVOK  := false;
  469.  OS2OK := false;
  470.  WinOK := false;
  471.  WinNtOK := false;    { This could also be just plain old Dos 5.0+ }
  472.  
  473.  DOS_Major := DosVer(DOS_Minor,Os2Vers);
  474.  If Os2Vers in [1,2] then
  475.    Os2OK := true
  476.  else
  477.    DVOK := DV_Check_On;
  478.  
  479.  If (not DVOK) and (not Os2OK) then
  480.   begin
  481.     WinOK := Win3_Check_On;
  482.     If Not WinOK then
  483.       Case Dos_Major of
  484.          5..9  : D5 := TrueDosVer(WinNtOK);
  485.        end;
  486.    end;
  487.  
  488.   If DVOK then
  489.        Tasker := 1
  490.   else
  491.   If WinOK then
  492.        Tasker := 2
  493.   else
  494.   If Os2OK then
  495.        Tasker := 3
  496.   else
  497.   If WinNtOK then
  498.       Tasker := 4
  499.   else
  500.   if D5 >= 5 then
  501.       Tasker := 5;
  502. end;
  503.  
  504. begin
  505.  FindTaskerType;
  506.  hexon:=false;
  507.  new(screen);
  508. end.